home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / PRINTINC.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-01-25  |  13.6 KB  |  623 lines
  1. ;* PRINTINC.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        A recursive print routine                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 10 Feb 87:    fixed problem printing circular data structs (tc)    *
  18. ;* - 21 Jan 88:    binary I/O uses line-length = 0 (rb)            *
  19. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23. IDEAL
  24. %PAGESIZE    60, 132
  25. MODEL    medium
  26. LOCALS    @@
  27.  
  28.     INCLUDE    "scheme.ash"
  29.  
  30. TEST_NUM EQU    8
  31. HEAPERR    EQU    -3
  32.  
  33. DATASEG
  34.  
  35. show    DB    SP_OUTPUT or SP_SEPARE
  36. ccount    DW    0
  37.  
  38. CODESEG
  39. ;***********************************************************************
  40. ;    Print a single character to the file, and send a newline if necessary.
  41. ;***********************************************************************
  42. PROC C    printchar, @@char:WORD
  43.     inc    [ccount]
  44.     test    [show], SP_OUTPUT
  45.     jz    @@ret
  46.     call    currspc         ; check spaces remaining
  47.     or    ax, ax
  48.     jle    @@skip
  49. @@cometothinkofit:
  50.     call    givechar C, [@@char]
  51.     jmp    @@ret
  52. @@skip:
  53.     test    [pflags], PORT_BINARY
  54.     jnz    @@cometothinkofit
  55.     mov    ax, LF
  56.     call    givechar C, ax         ; newline
  57.     call    iswhitespace C, [@@char]; after newline, print nonspaces
  58.     test    ax, ax
  59.     jz    @@cometothinkofit
  60. @@ret:
  61.     ret
  62. ENDP    printchar
  63.  
  64. ;************************************************************************
  65. ;    Wrap issues a newline if there are less than LEN spaces
  66. ; left on the current output line.
  67. ;************************************************************************
  68. PROC C    wrap, @@len:WORD
  69.     mov    dx, [@@len]
  70.     test    [show], SP_OUTPUT
  71.     jz    @@ret
  72.     call    curr_col
  73.     cmp    ax, 1
  74.     jle    @@ret
  75.     call    currspc         ; get the available spaces
  76.     cmp    ax, dx
  77.     jge    @@ret
  78.     mov    ax, LF            ; issue a newline
  79.     call    givechar C, ax
  80. @@ret:
  81.     ret
  82. ENDP    wrap
  83.  
  84. ;************************************************************************
  85. ;    Print the string with length LEN, first sending a newline
  86. ; if necessary.
  87. ;************************************************************************
  88. PROC C    printstr, @@string:WORD, @@len:WORD
  89.     call    wrap C, [@@len]        ; check available spaces
  90.     mov    ax, [@@len]
  91.     add    [ccount], ax
  92.     test    [show], SP_OUTPUT
  93.     je    @@ret
  94.     call    gvchars C, [@@string], [@@len]
  95. @@ret:
  96.     ret
  97. ENDP    printstr
  98.  
  99. ;************************************************************************
  100. ;    Return number of spaces remaining on current line
  101. ;************************************************************************
  102. PROC    currspc    NEAR
  103.     push    es bx
  104.     mov    bx, [port_reg.page]
  105.     ldpage    es, bx
  106.     mov    bx, [port_reg.disp]
  107.     mov    ax, [(PORTDEF es:bx).ncols]
  108.     test    ax, ax             ; line length defined?
  109.     jnz    @@defined
  110.     mov    ax, -1             ; no, return negative value
  111.     jmp    @@ret
  112. @@defined:
  113.     sub    ax, [(PORTDEF es:bx).curcol]
  114. @@ret:
  115.     pop    bx es
  116.     ret
  117. ENDP    currspc
  118.  
  119. ;************************************************************************
  120. ;            Return current column
  121. ;************************************************************************
  122. PROC    curr_col    NEAR
  123.     push    es bx
  124.     mov    bx, [port_reg.page]
  125.     ldpage    es, bx
  126.     mov    bx, [port_reg.disp]
  127.     mov    ax, [(PORTDEF es:bx).ncols]
  128.     or    ax, ax             ; Maintaining column?
  129.     jz    @@ret
  130.     mov    ax, [(PORTDEF es:bx).curcol]    ; Yes, get column and return
  131. @@ret:
  132.     pop    bx es
  133.     ret
  134. ENDP    curr_col
  135.  
  136. ;************************************************************************
  137. ;    The main print routine
  138. ;************************************************************************
  139. PROC C    sprint    USES si di, @@page:WORD, @@disp:WORD, @@portpage:WORD, @@portdisp:WORD
  140.     mov    [ccount], 0
  141.     call    ssetadr C, [@@portpage], [@@portdisp]
  142.  
  143.     mov    bx, [port_reg.page]    ; fix for random i/o - note a write has taken place
  144.     ldpage    es, bx
  145.     mov    si, [port_reg.disp]
  146.     and    [(PORTDEF es:si).pflags], NOT PORT_FLUSHED ; mark as modified
  147.  
  148.     call    subsprint C, [@@page], [@@disp]
  149.     mov    ax, [ccount]
  150.     ret
  151. ENDP    sprint
  152.  
  153. ;************************************************************************
  154. ;* Recursive local object printing                    *
  155. ;************************************************************************
  156. PROC C    subsprint    NEAR, @@page:WORD, @@disp:WORD
  157. DATASEG
  158. @@abort    DB    "[WARNING: Output aborted by SHIFT-BREAK]"
  159. LABEL    @@abort_
  160. @@deep    DB    "#<DEEP!>"
  161. LABEL    @@deep_
  162. CODESEG
  163.     cmp    [s_break], 0         ; check for SHIFT-BREAK
  164.     je    @@goahead
  165. @@dead:
  166.     mov    ax, LF
  167.     call    givechar C, ax
  168.     mov    ax, @@abort_ - @@abort
  169.     lea    bx, [@@abort]
  170.     call    printstr C, bx, ax    ; display message
  171.     xor    ax, ax
  172.     test    [show], SP_OUTPUT
  173.     jnz    @@donthide
  174.     add    ax, 2
  175. @@donthide:
  176.     call    restart C, ax
  177.  
  178. @@goahead:
  179.     call    stkspc             ; check stack space
  180.     cmp    ax, 64             ; stack low?
  181.     jge    @@stackok
  182.     mov    ax, @@deep_ - @@deep
  183.     lea    bx, [@@deep]
  184.     call    printstr C, bx, ax    ; print no deeper
  185.     jmp    @@ret
  186.  
  187. @@stackok:
  188.     shl    [@@page], 1         ; adjust page number
  189.     mov    bx, [@@page]
  190.     mov    di, [WORD ptype+bx]
  191.     jmp    [@@branchtab+di]
  192. DATASEG
  193. LABEL    @@branchtab    WORD
  194.     DW    @@list             ; [0] LISTTYPE
  195.     DW    @@fixnum         ; [1] FIXTYPE
  196.     DW    @@flonum        ; [2] FLOTYPE
  197.     DW    @@bignum        ; [3] BIGTYPE
  198.     DW    @@symbol        ; [4] SYMBTYPE
  199.     DW    @@string        ; [5] STRTYPE
  200.     DW    @@array            ; [6] ARYTYPE
  201.     DW    @@continuation         ; [7] CONTTYPE
  202.     DW    @@closure         ; [8] CLOSTYPE
  203.     DW    @@free             ; [9] FREETYPE
  204.     DW    @@code             ; [10] CODETYPE
  205.     DW    @@inline        ; [11] I86TYPE
  206.     DW    @@port             ; [12] PORTTYPE
  207.     DW    @@char             ; [13] CHARTYPE
  208.     DW    @@environment        ; [14] ENVTYPE
  209. CODESEG
  210. @@list:
  211. DATASEG
  212. @@nil    DB    "()"
  213. LABEL    @@nil_
  214. CODESEG
  215.     test    bx, bx             ; null page?
  216.     jnz    @@notnil
  217.     mov    ax, @@nil_ - @@nil
  218.     lea    bx, [@@nil]
  219.     call    printstr C, bx, ax
  220.     jmp    @@ret
  221. @@notnil:
  222.     mov    dx, '('
  223.     call    printchar C, dx
  224.     mov    bx, [@@page]         ; Get page
  225.     ldpage    es, bx         ; Get paragraph address of page
  226.     mov    si, [@@disp]         ; dispacement
  227. @@listloop:
  228.     push    bx si
  229.     xor    dh, dh
  230.     mov    dl, [(LISTDEF es:si).car.page]
  231.     shr    dx, 1             ; Change to number for subsprint
  232.     mov    cx, [(LISTDEF es:si).car.disp]
  233.     call    subsprint C, dx, cx
  234.     pop    si bx
  235.     ldpage    es, bx
  236.     mov    bl, [(LISTDEF es:si).cdr.page]
  237.     mov    si, [(LISTDEF es:si).cdr.disp]
  238.     test    bx, bx             ; more items in list?
  239.     jz    @@listdone
  240.     push    bx si
  241.     mov    dx, ' '
  242.     call    printchar C, dx
  243.     pop    si bx
  244.     ldpage    es, bx
  245.     cmp    [ptype+bx], LISTTYPE
  246.     je    @@listloop
  247.     push    bx si                ; dotted list
  248.     mov    dx, '.'
  249.     call    printchar C, dx
  250.     mov    dx, ' '
  251.     call    printchar C, dx
  252.     pop    si bx
  253.     shr    bx, 1             ; corrected page number
  254.     call    subsprint C, bx, si
  255. @@listdone:
  256.     mov    dx, ')'
  257.     call    printchar C, dx
  258.     jmp    @@ret
  259.  
  260. @@fixnum:
  261.     mov    ax, 5
  262.     call    malloc C, ax
  263.     or    ax, ax
  264.     jz    @@memerror
  265.     push    ax
  266.     call    fix2big C, [@@disp], ax    ; change to bignum
  267.     pop    ax            ; put buffer address in ax
  268.     mov    bx, 5            ; put length in bx
  269.     jmp    @@printint
  270.  
  271. @@memerror:
  272.     mov    ax, HEAPERR         ; memory not available
  273.     call    errmsg C, ax
  274.     mov    ax, -1            ; signal error
  275.     jmp    @@errorret
  276.  
  277. @@flonum:
  278. LOCALFLO = 8
  279.     sub    sp, LOCALFLO
  280.     ldpage    es, bx
  281.     mov    si, [@@disp]
  282.     fld    [(FLODEF es:si).data]
  283.     fstp    [QWORD bp-LOCALFLO]
  284.     call    printflo C
  285.     add    sp, LOCALFLO
  286.     jmp    @@ret
  287.  
  288. @@array:
  289. DATASEG
  290. @@arraystart    DB    "#("
  291. LABEL    @@arraystart_
  292. CODESEG
  293.     mov    ax, @@arraystart_ - @@arraystart
  294.     lea    bx, [@@arraystart]
  295.     call    printstr C, bx, ax
  296.  
  297.     ldpage    es, [@@page]
  298.     mov    si, [@@disp]
  299.     mov    cx, [(VECDEF es:si).len]
  300.     sub    cx, OFFSET (TYPE VECDEF).data+SIZE POINTER
  301.     xor    bx, bx
  302. @@arrayloop:
  303.     cmp    bx, cx
  304.     jle    @@nextarraycell
  305.     jmp    @@listdone
  306. @@nextarraycell:
  307.     mov    al, [(VECDEF es:si+bx).data.page]
  308.     mov    dx, [(VECDEF es:si+bx).data.disp]
  309.     xor    ah, ah
  310.     shr    ax, 1             ; Page number for subsprint
  311.     push    bx cx si
  312.     call    subsprint C, ax, dx
  313.     pop    si cx bx
  314.     cmp    bx, cx            ; last element?
  315.     jge    @@arraylast
  316.     push    bx cx si
  317.     mov    dx, ' '
  318.     call    printchar C, dx
  319.     pop    si cx bx
  320. @@arraylast:
  321.     add    bx, SIZE POINTER
  322.     ldpage    es, [@@page]
  323.     jmp    @@arrayloop
  324.  
  325. @@continuation:
  326. DATASEG
  327. @@contmsg    DB    "#<CONTINUATION>"
  328. LABEL    @@contmsg_
  329. CODESEG
  330.     mov    ax, @@contmsg_ - @@contmsg
  331.     lea    bx, [@@contmsg]
  332.     call    printstr C, bx, ax
  333.     jmp    @@ret
  334.  
  335. @@closure:
  336. DATASEG
  337. @@closmsg    DB    "#<PROCEDURE"
  338. LABEL    @@closmsg_
  339. CODESEG
  340.     mov    ax, @@closmsg_ - @@closmsg
  341.     lea    bx, [@@closmsg]
  342.     call    printstr C, bx, ax
  343.     ldpage    es, [@@page]        ; fetch information operand from closure object
  344.     mov    si, [@@disp]
  345.     xor    bh, bh
  346.     mov    bl, [(CLOSDEF es:si).info.page]
  347.     mov    si, [(CLOSDEF es:si).info.disp]
  348. @@closloop:
  349.     ldpage    es, bx
  350.     or    bx, bx            ; nil ?
  351.     je    @@endoflist
  352.     cmp    [ptype+bx], LISTTYPE    ; symbol ?
  353.     jne    @@endoflist
  354.     mov    bl, [(LISTDEF es:si).cdr.page]
  355.     mov    si, [(LISTDEF es:si).cdr.disp]
  356.     jmp    @@closloop
  357. @@endoflist:
  358.     cmp    [ptype+bx], SYMBTYPE
  359.     jne    @@closdone
  360.     mov    cx, [(SYMDEF es:si).len]
  361.     sub    cx, OFFSET (TYPE SYMDEF).buffer - 1
  362.     push    bx cx
  363.     call    malloc C, cx
  364.     pop    cx bx
  365.     or    ax, ax
  366.     jne    @@closallocok
  367.     jmp    @@memerror
  368. @@closallocok:
  369.     push    ax cx            ; save fresh string space and length
  370.     sar    bx, 1
  371.     call    get_sym C, ax, bx, si    ; get the symbol name
  372.     mov    dx, ' '
  373.     call    printchar C, dx
  374.     pop    cx ax
  375.     push    ax
  376.     dec    cx            ; decrement length
  377.     call    printstr C, ax, cx
  378.     pop    ax
  379.     call    free C, ax
  380. @@closdone:
  381.     mov    dx, '>'
  382.     call    printchar C, dx
  383.     jmp    @@ret
  384.  
  385. @@free:
  386. DATASEG
  387. @@freemsg    DB    "#<FREE>"
  388. LABEL    @@freemsg_
  389. CODESEG
  390.     mov    ax, @@freemsg_ - @@freemsg
  391.     lea    bx, [@@freemsg]
  392.     call    printstr C, bx, ax
  393.     jmp    @@ret
  394.  
  395. @@inline:
  396. DATASEG
  397. @@inlinemsg    DB    "#<INLINE>"
  398. LABEL    @@inlinemsg_
  399. CODESEG
  400.     mov    ax, @@inlinemsg_ - @@inlinemsg
  401.     lea    bx, [@@inlinemsg]
  402.     call    printstr C, bx, ax
  403.     jmp    @@ret
  404.  
  405. @@code:
  406. DATASEG
  407. @@codemsg    DB    "#<CODE>"
  408. LABEL    @@codemsg_
  409. CODESEG
  410.     mov    ax, @@codemsg_ - @@codemsg
  411.     lea    bx, [@@codemsg]
  412.     call    printstr C, bx, ax
  413.     jmp    @@ret
  414.  
  415. @@environment:
  416. DATASEG
  417. @@envmsg    DB    "#<ENVIRONMENT>"
  418. LABEL    @@envmsg_
  419. CODESEG
  420.     mov    ax, @@envmsg_ - @@envmsg
  421.     lea    bx, [@@envmsg]
  422.     call    printstr C, bx, ax
  423.     jmp    @@ret
  424.  
  425. @@symbol:
  426.     mov    ax, '|'
  427.     mov    cx, SIZE SYMDEF
  428.     mov    si, [@@disp]
  429.     shr    bx, 1             ; corrected page number
  430.     call    printatm C, bx, si, cx, ax
  431.     jmp    @@ret
  432.  
  433. @@string:
  434.     ldpage    es, bx
  435.     mov    si, [@@disp]
  436.     sstrlen    cx, <es:si>, OVERHEAD
  437.     sub    cx, OFFSET (TYPE STRDEF).buffer
  438.     add    [ccount], cx
  439.     test    [show], SP_OUTPUT
  440.     jnz    @@putstring
  441.     jmp    @@ret
  442. @@putstring:
  443.     test    [show], SP_SEPARE
  444.     jnz    @@sepstring
  445.  
  446.     push    cx si
  447.     call    wrap C, cx
  448.     pop    si cx
  449.     xor    bx, bx
  450. @@plainloop:
  451.     cmp    bx, cx
  452.     jl    @@plainmore
  453.     jmp    @@ret
  454. @@plainmore:
  455.     cmp    [s_break], 0         ; check for SHIFT-BREAK
  456.     je    @@plainok
  457.     jmp    @@dead
  458. @@plainok:
  459.     ldpage    es, [@@page]
  460.     mov    al, [(STRDEF es:si+bx).buffer]
  461.     xor    ah, ah
  462.     push    bx
  463.     call    givechar C, ax
  464.     pop    bx
  465.     inc    bx
  466.     jmp    @@plainloop
  467.  
  468. @@sepstring:
  469.     xor    bx, bx
  470.     mov    dx, 2             ; at least 2 chars to add: ""
  471. @@scanstring:
  472.     cmp    bx, cx
  473.     jge    @@scandone
  474.     mov    al, [(STRDEF es:si+bx).buffer]
  475.     inc    bx
  476.     cmp    al, '\'
  477.     je    @@scanspecial
  478.     cmp    al, '"'
  479.     jne    @@scanstring
  480. @@scanspecial:
  481.     inc    dx
  482.     jmp    @@scanstring
  483. @@scandone:
  484.     add    [ccount], dx        ; update this count, too
  485.     add    dx, cx            ; total char count
  486.     push    cx si
  487.     call    wrap C, dx
  488.     pop    si cx
  489.     mov    ax, '"'
  490.     call    givechar C, ax
  491.     xor    bx, bx
  492. @@seploop:
  493.     cmp    bx, cx
  494.     jge    @@sepdone
  495.     cmp    [s_break], 0         ; check for SHIFT-BREAK
  496.     je    @@sepok
  497.     jmp    @@dead
  498. @@sepok:
  499.     ldpage    es, [@@page]
  500.     mov    dl, [(STRDEF es:si+bx).buffer]
  501.     xor    dh, dh
  502.     inc    bx
  503.     push    bx
  504.     cmp    dl, '\'
  505.     je    @@sepspecial
  506.     cmp    dl, '"'
  507.     jne    @@sepnormal
  508. @@sepspecial:
  509.     mov    ax, '\'
  510.     push    dx
  511.     call    givechar C, ax
  512.     pop    dx
  513. @@sepnormal:
  514.     call    givechar C, dx
  515.     pop    bx
  516.     jmp    @@seploop
  517. @@sepdone:
  518.     mov    ax, '"'
  519.     call    givechar C, ax
  520.     jmp    @@ret
  521.  
  522. @@char:
  523. LOCALCHAR = 14
  524.     mov    cx, [@@disp]
  525.     test    [show], SP_SEPARE
  526.     jz    @@rawchar
  527.     sub    sp, LOCALCHAR        ; allocate a buffer on the stack
  528.     lea    si, [bp-LOCALCHAR]
  529.     mov    [WORD si], '\#'        ; check for a special multi-character character constant
  530.     mov    [BYTE si+2], cl
  531.     mov    [BYTE si+3], 0
  532.     xor    bx, bx
  533. @@multiloop:
  534.     cmp    bl, SPECIALCHARS*2    ; end of comparison?
  535.     jl    @@multimore
  536.     mov    bx, 3
  537.     jmp    @@stringchar
  538. @@multimore:
  539.     mov    di, [spchars+bx]
  540.     cmp    cl, [di]         ; compare with special char
  541.     je    @@multifound
  542.     inc    bx
  543.     inc    bx
  544.     jmp    @@multiloop
  545.  
  546. @@multifound:
  547.     mov    bx, 2            ; length is at least 2
  548.     inc    di
  549. @@multicopy:
  550.     cmp    [BYTE di], 0         ; end of string?
  551.     je    @@multiend
  552.     mov    al, [di]
  553.     mov    [si+bx], al        ; move character by character
  554.     inc    bx
  555.     inc    di
  556.     jmp    @@multicopy
  557. @@multiend:
  558.     mov    [BYTE si+bx], 0
  559. @@stringchar:
  560.     call    printstr C, si, bx
  561.     add    sp, LOCALCHAR
  562.     jmp    @@ret
  563. @@rawchar:
  564.     call    printchar C, cx
  565.     jmp    @@ret
  566.  
  567. @@bignum:
  568.     ldpage    es, bx
  569.     mov    si, [@@disp]
  570.     mov    ax, [(BIGDEF es:si).data.len]
  571.     dec    ax
  572.     push    ax
  573.     call    malloc C, ax        ; allocate memory for divider
  574.     or    ax, ax
  575.     jne    @@bignumok
  576. @@bignumerror:
  577.     pop    ax            ; thrash off
  578.     jmp    @@memerror
  579. @@bignumok:
  580.     mov    bx, [@@page]
  581.     shr    bx, 1
  582.     push    ax
  583.     call    copybig C, bx, si, ax    ; copy bignum to buffer
  584.     pop    ax bx            ; restore the size & bignum
  585. @@printint:                ; here ax=bignum's address, bx=len
  586.     push    ax            ; save the bignum's address
  587.     mov    ax, bx
  588.     add    ax, bx
  589.     add    ax, bx
  590.     sub    ax, 5
  591.  
  592.     call    malloc C, ax        ; allocate memory for char buffer
  593.     or    ax, ax
  594.     je    @@bignumerror
  595.     pop    bx            ; get the bignum
  596.     push    bx ax            ; save the bignum & char buffer
  597.  
  598.     call    big2asc C, bx, ax ; convert bignum to char string
  599.     pop    bx
  600.     push    bx            ; get a look at the char buffer
  601.     call    printstr C, bx, ax    ; print the bignum
  602.     pop    ax
  603.     call    free C, ax
  604.     pop    ax
  605.     call    free C, ax
  606.     jmp    @@ret
  607.  
  608. @@port:
  609. DATASEG
  610. @@portmsg    DB    "#<PORT>"
  611. LABEL    @@portmsg_
  612. CODESEG
  613.     mov    ax, @@portmsg_ - @@portmsg
  614.     lea    bx, [@@portmsg]
  615.     call    printstr C, bx, ax
  616. @@ret:
  617.     xor    ax, ax            ; no carry = success
  618. @@errorret:
  619.     ret
  620. ENDP    subsprint
  621.  
  622.     END
  623.